Collaborative Movie Recommender

R-Version: [Default] [32-bit] C:\Program Files\R\R-4.1.0

In folgendem Notebook werden anhand des MovieLense Datensatzes aus dem Paket RecommenderLab verschiedene Recommender erstellt. Es werden verschiedene Recommender und verschiedene Ähnlichkeiten verwendet, um diese zu vergleichen und auszuwerten. Ziel ist es, ein möglichst guter Recommender zu erstellen und zu verstehen wie dieser funktioniert. Zudem soll verstanden werden wie dieser bewertet wird und was in diesem Falle ein ‘guter’ Recommender bedeutet.

Dieses Notebook konzentriert sich auf Erkenntnisse von Auswertungen und Vergleichen. Um eine bessere Übersicht zu erhalten wurden grosse, sich widerholende Codes im Helperfile helper.R ausgelagert.

---

Explorative Datenanalyse

set.seed(42)
df_1 <- movies %>% group_by(item) %>%  summarize(mean_rating = mean(rating), count = n()) %>% sample_n(15) %>% arrange(desc(mean_rating))

p1 <- ggplot(df_1, aes(y = reorder(item, +mean_rating), x = mean_rating)) +
  geom_col(alpha = 1, fill = 'steelblue') +
  scale_y_discrete(expand = c(0,0)) +
  scale_x_continuous(expand = c(0,0)) +
  geom_text(aes(label=round(mean_rating,2)), hjust = 1.3, color = 'white') +
  labs(
    title = "Durchschnittliche Filmbewertung",
    subtitle = "Zufällige Stichprobe von 15 Filmen",
    y = element_blank(),
    x = "Durchschnittliche Bewertung in Sternen"
  ) +
  theme_classic() +
  theme(axis.text.x = element_blank(),
        axis.ticks.x = element_blank(),
        axis.line.x = element_blank(),
        text = element_text(size = 12) # text size
  )

p2 <- ggplot(df_1, aes(y = reorder(item, +mean_rating), x = count)) +
  geom_col(alpha = 1, fill = 'steelblue') +
  scale_y_discrete(expand = c(0,0)) +
  scale_x_continuous(limit = c(0,125), expand = c(0,0)) +
  geom_text(aes(label=count), hjust = -.3, color = 'black') +
  labs(
    title = "Anzahl Bewertungen",
    subtitle = "Zufällige Stichprobe von 15 Filmen",
    y = element_blank(),
    x = "Anzahl Bewertungen"
  ) +
  theme_classic() +
  theme(axis.text.x = element_blank(),
        axis.ticks.x = element_blank(),
        axis.line.x = element_blank(),
        text = element_text(size = 12) # text size
  )

grid.arrange(p1, p2, ncol = 2, nrow = 1)

Um einen ersten Überblick über die Daten zu erhalten wurde hier ein Plot von 15 zufällig gewählten Filmen samt der Durchschnittsbewertung und Anzahl Bewertungen geplottet. Es fällt auf, dass besonders schlecht bewertete Filme oft auch weniger angeschaut wurden.

---

1. Welches sind die am häufigsten geschauten Genres / Filme?

movies_genre <- MovieLenseMeta %>%
  rename(item = title)
movies_genre$url <- NULL
movies_genre[movies_genre == 0] <- NA
a <- which(movies_genre==1,arr.ind=TRUE)
movies_genre[a] <- names(movies_genre)[a[,"col"]]
movies_genre <- movies_genre %>%
  unite("genres", unknown:Western, sep= ",", 
        remove = TRUE, na.rm = TRUE)
genres<-merge(x=movies,y=movies_genre,by="item",all.x=TRUE)%>%
  mutate(genres = strsplit(as.character(genres), ",")) %>%
  unnest(genres)

df1a <- movies%>%
  group_by(item)%>%
  summarize(count=n())%>%
  ungroup()%>%
  arrange(desc(count))

df1a <- head(df1a, 10)

df1a %>%
  mutate(item = fct_reorder(item, count))%>%
  ggplot(aes(x = count, y = item))+
  geom_col(alpha = 1, fill = 'steelblue')+
  scale_y_discrete(expand = c(0,0)) +
  scale_x_continuous(expand = c(0,0)) +
  geom_text(aes(label=round(count,2)), hjust = 1.3, color = 'white') +
  labs(
    title = "Meist bewertete Filme",
    y = element_blank(),    x = "Anzahl Bewertungen"
  ) +
  theme_classic() +
  theme(axis.text.x = element_blank(),
        axis.ticks.x = element_blank(),
        axis.line.x = element_blank(),
        text = element_text(size = 12) # text size
  )

Da in unserem Datensatz nur die Anzahl Ratings von Filmen gegeben ist, gehen wir davon aus, dass die meist bewerteten, auch die meist angeschauten Filme sind. In der Grafik sieht man die 10 meist bewerteten Filme.

df1b <- genres%>%
  group_by(genres)%>%
  summarize(count=n())%>%
  ungroup()%>%
  arrange(desc(count))

df1b%>%
  mutate(genres = fct_reorder(genres, count))%>%
  ggplot(aes(x = count, y = genres))+
  geom_col(alpha = 1, fill = 'steelblue')+
  geom_text(aes(label=round(count,2)), hjust = -0.2, color = 'black') +
  scale_y_discrete(expand = c(0,0)) +
  scale_x_continuous(expand = c(0,0), limits = c(0,45000)) +
  geom_text(aes(label=count,2), hjust = 1.3, color = 'white') +
  labs(
    title = "Meist bewertete Genres",
    y = element_blank(),    x = "Anzahl Bewertungen"
  ) +
  theme_classic() +
  theme(axis.text.x = element_blank(),
        axis.ticks.x = element_blank(),
        axis.line.x = element_blank(),
        text = element_text(size = 12) # text size
  )

Auch hier wird davon ausgegangen, dass die Genres, welche am häufigsten bewertet wurden auch am häufigsten geschaut wurden. In der Grafik ist zu sehen, dass Drama das top Genres ist, gefolgt von Comedy und Action. Dies stimmt auch mit unserer eigenen Filmerfahrung überein.

---

2. Wie verteilen sich die Kundenratings gesamthaft und nach Genres?

ggplot(movies, aes(x = rating)) +
  geom_bar(alpha = 1, fill = 'steelblue') +
  geom_text(stat='count', aes(label=..count..), vjust=1.5, color = 'white') +
  scale_y_continuous(expand = c(0,0)) +
  scale_x_continuous(expand = c(0,0)) +
  labs(
    title = "Verteilung Kundenratings gesamthaft",
    subtitle = paste("N = ", nrow(movies), " Bewertungen"),
    x = "Kundenbewertungen", 
    y = "Anzahl",
    fill = element_blank()
  ) +
  theme_classic() +
  theme(
    text = element_text(size = 12)
  )

In dieser Grafik ist die Verteilung der Ratings zu sehen. Die Ratings 3 und 4 werden klar am häufigsten vergeben, wobei Filme eher selten mit den Ratings 1 und 2 bewertet werden. Eine möglice Erklärung wäre, dass User eher eine Bewertung für Filme abgeben, welche sie auch für gut empfunden haben.

# get rating count per user, add as column for further processing
counts <- movies %>% group_by(user) %>% count()
movies2 <- merge(movies, counts, by="user")
movies_wider2 <- merge(movies_wider, counts, by="user")

# avoid users with almost no ratings, use median as threshold
median_count <- median(counts$n)

# get sample
set.seed(623)
movies_sample <- movies_wider2 %>% filter(n > median_count) %>% sample_n(5)

# create long table
movies_sample_long <- filter(movies2, user %in% movies_sample$user)

# drop item names, 
movies_sample_long <- subset(movies_sample_long, select = -c(item))

df2b <- genres%>%
  group_by(genres)
  
movies_sample_long_grouped <- movies_sample_long %>% group_by(user, rating) %>% summarise(rating_dens = length(user) / first(n), user = first(user), n=first(n), rating = first(rating))
  
ggplot(genres, aes(x = rating, fill = genres)) +
  geom_bar(alpha = 1, bins = 10) +
  facet_wrap(~genres)+
  scale_y_continuous(expand = c(0,0)) +
  scale_x_continuous(expand = c(0,0)) +
  labs(
    title = "Verteilung Kundenratings nach Genres",
    subtitle = paste("N = ", nrow(movies), " Bewertungen"),
    x = "Durchschnittliche Bewertung", 
    y = "Anzahl",
    fill = element_blank()
  ) +
  theme(
    text = element_text(size = 12),
    legend.position = 'none'
  )

Hier ist zu sehen, dass das Genres Drama am meisten bewertet wurde, wobei Dokumentationen am wenigsten Bewertungen erhalten haben. Die Bewertungen pro Genres verteilen sich jeweils sehr ähnlich. Die Verteilungen der einzelnen Genres sind ebenfalls ähnlich verteilt wie die Bewertungen gesamthaft.

---

3.Wie verteilen sich die mittleren Kundenratings pro Film?

df3 <- movies %>% 
  group_by(item) %>%  
  summarize(
    mean_rating = mean(rating),
    ratings = n()
  ) %>% 
  mutate(
    more_than_50 = ifelse(ratings >= 50, 'b) mehr als 50 Bewertungen', 'a) weniger als 50 Bewertugen')
  )

ggplot(df3, aes(x = mean_rating)) +
  geom_histogram(alpha = 1, fill = 'steelblue', binwidth = 0.06) +
  scale_y_continuous(expand = c(0,0)) +
  scale_x_continuous(expand = c(0,0)) +
  labs(
    title = "Verteilung mittlere Kundenratings pro Film",
    subtitle = paste("N = ", nrow(movies), " Bewertungen"),
    x = "Durchschnittliche Bewertung", 
    y = "Dichte"
  ) +
  theme_classic() +
  theme(text = element_text(size = 12)
  )

In dieser Grafik ist die durchschnittliche Bewertung pro Film zu sehen, wobei auch hier zu sehen ist, dass die meisten Filme eine durchschnittliche Bewertung von ca. 3 - 3.5 haben. Auffällig ist, dass bei den ganzen Zahlen (1, 2, 3, 4 & 5) besonders viele Bewertungen zu sehen sind. Dies liegt an den Filmen, welche nur wenige oder nur eine Bewertung erhalten haben.

ggplot(df3, aes(x = mean_rating, fill = more_than_50)) +
  geom_density(alpha = 0.5, bw = 0.08) +
  scale_y_continuous(expand = c(0,0)) +
  scale_x_continuous(expand = c(0,0)) +
  labs(
    title = "Verteilung mittlere Kundenratings pro Film",
    x = "Durchschnittliche Bewertung", 
    y = "Dichte",
    fill = element_blank()
  ) +
  theme_classic() +
  theme(
    text = element_text(size = 12),
    legend.position = 'bottom'
  )

Für diese Grafik wurden die Filme in zwei Gruppen unterteilt: Filme die weniger als 50 bewertungen erhalten haben, und Filme welche mehr als 50 Bewertungen erhalten haben. In der Grafik ist ebenfalls die durchschnittliche Bewertung der Filme zu sehen, wobei deutlich erkannt werden kann, dass Filme, welche weniger Bewertungen erhalten haben, tendenziell auch schlechter bewertet wurden.

---

4.Wie stark streuen die Ratings von individuellen Kunden?

# Number of ratings per user per rating value
movies_sample_long_grouped <- movies_sample_long %>% group_by(user, rating) %>% summarise(rating_dens = length(user) / first(n), user = first(user), n=first(n), rating = first(rating))

movies_span <- movies %>% group_by(user) %>% 
  summarize(mean = mean(rating), min = min(rating), max = max(rating), span = (max(rating) - min(rating)))

set.seed(123)

ggplot(movies_span  %>% group_by(span) %>% summarise(count = n()), aes(x=span, y=count)) +
  geom_col(fill = 'steelblue') +
  scale_y_continuous(limits = c(0,800), expand = c(0,0)) +
  geom_text(aes(label=round(count,2)), vjust = -0.7, color = 'black') +
  labs(
    title = "Spannweite Kundenratings",
    subtitle = "",
    x = "Spannweite", 
    y = "Anzahl User"
  )+
    theme_classic() + 
  theme(
    text = element_text(size = 12),
    legend.position = 'bottom'
  )

In dieser Grafik ist die Spannweite aller Kunden dargestellt. Hier wird sichtbar, dass die meisten User Bewertungen von 1-5 abgegeben haben (Spannweite = 4), und nur weinige sehr homogen bewertet haben (Spannweite = 1-2). Eine kleine Spannweite kann hier natürlich auch aufgetreten sein, weil diese Kunden gesamthaft sehr wenige Bewertungen abgegeben haben.

---

5.Welchen Einfluss hat die Normierung der Ratings pro Kunde auf deren Verteilung?

movies_sample_long_grouped <- movies %>% group_by(rating) %>% summarise(rating_dens = n())

ggplot(movies_sample_long_grouped, aes(x=rating, y = rating_dens)) + 
  geom_col(fill = 'steelblue') +
  scale_y_continuous(expand = c(0,0)) +
  geom_text(aes(label=round(rating_dens,2)), vjust = 1.5, color = 'white') +
  labs(
    title = "Häufigkeit der Kundenbewertungen",
    subtitle = paste("N =",  nrow(movies), " Bewertungen"),
    x = "User Bewertung (1-5)", 
    y = "Anzahl Bewertungen",
    fill = element_blank()
  ) +
  scale_fill_manual("legend", values = c("cyan3", "cyan4", "darkolivegreen3", "darkolivegreen", "coral4")
                    )+
  theme_classic() + 
  theme(
    text = element_text(size = 12),
    legend.position = 'bottom'
  )

Hier ist noch einmal die Grafik mit der Verteilung der Kundenratings bevor diese normiert wurden. Es fällt auf, dass diese diskret ist.

MovNorm <- normalize(MovieLense, method="Z-score")
mov <- as(MovNorm, "data.frame")

ggplot(mov, aes(x=rating)) + 
  geom_histogram(fill = 'steelblue', bins = 70) +
  scale_y_continuous(expand = c(0,0)) +
  scale_x_continuous(expand = c(0,0)) +
  labs(
    title = "Häufigkeit der Kundenbewertungen",
    subtitle = paste("N = ", nrow(mov), "Bewertungen"),
    x = "User Bewertung Normiert", 
    y = "Anzahl Bewertungen",
    fill = element_blank()
  ) +
  scale_fill_manual("legend", values = c("cyan3", "cyan4", "darkolivegreen3", "darkolivegreen", "coral4")
                    )+
  theme_classic() + 
  theme(
    text = element_text(size = 12),
    legend.position = 'bottom'
  )

Die Ratings sind nun ungefähr Normalverteilt mit einem Durchschnittsrating von 0 und einer Standardabweichung von 1. Erkennbar ist, dass die Verteilung rechtssteil und linksschief ist, weil mehrheitlich positive Bewertungen abgegeben wurden. Durch die Normierung der Daten werden die Ratings jedes Users auf dieselbe Verteilung gestaucht, wodurch man die Verteilung aller Daten analysieren kann. Dadurch hat man beispielsweise die Möglichkeit die durchschnittliche Bewertungstendenz herauszufinden.

---

6.Welche strukturellen Charakteristika (z.B. Sparsity) und Auffälligkeiten zeigt die User Item Matrix?

image(as(MovieLense, "dgCMatrix"))

In dieser Grafik werden die Bewertungen von Usern (Row) den Filmen (Column) gegenübergestellt. Die Achsenbeschriftung konnte nicht besser speizifiziert werden. Users mit tiefen ID’s und Filme mit hohen ID’s weisen weniger Ratings auf. Filme mit tiefer ID jedoch sehr viele. Auffallend ist, dass es einige wenige User gibt, die fast alle Filme bewertet haben (erkennbar durch die horizontalen scharzen Striche). Dies scheinen sehr aktive Bewerter zu sein. Viele User haben jedoch nur einen kleinen Teil der Filme bewertet. Bei den Filmen ist eine ähnliche Tendenz wahrzunehmen.

sparcity <- sum(is.na(movies_wider[,-1])) / prod(dim(movies_wider))
print(paste('Die Sparcity im Datensatz ist:',sparcity))

[1] "Die Sparcity im Datensatz ist: 0.936096223476923"

Die Sparcity ist ungefähr 0.936. Dies bedeutet, dass ungefähr 6.4% der Daten Non-NA-Values sind. Somit hat der Durchschnittliche User 6.4% der verfügbaren Filme bewertet. Die Matrix ist mit einer Sparcity von ca. 0.936 sehr sparce. Dies haben wir ungefähr so erwartet, da es sehr unwahrscheinlich ist, dass ein Film von allen Nutzern bewertet wird oder, dass ein Nutzer alle Filme anschaut und auch bewertet.

---

Datenreduktion

#Data reduction
dense_reduction <- data_reduction_dense(MovieLense)
dense_user_reduction <- data_reduction_dense_user(MovieLense)
random_reduction <- data_reduction_random(MovieLense)

#same as dense reduction
ratingMatrix <- data_reduction_dense(MovieLense)

matrices <- c('Original Matrix (MovieLense)', 'dense_reduction', 'dense_user_reduction', 'random_reduction')
sparsities <- c(get_sparsity(MovieLense), get_sparsity(dense_reduction), get_sparsity(dense_user_reduction), get_sparsity(random_reduction))

df_sparsity <- data.frame(matrix = matrices, sparsity = sparsities)

#Plot Data reduction
ggplot(df_sparsity, aes(x=matrix, y = sparsity)) + 
  geom_col(fill = 'steelblue') +
  coord_flip() +
  scale_y_continuous(expand = c(0,0)) +
  geom_text(aes(label=paste0(round(sparsity,2),'%')), hjust = 1.3, color = 'white') +
  labs(
    title = "Sparsity der verschiedenen Datenreduktionen",
    x = element_blank(), 
    y = "Sparcity in Prozent",
    fill = element_blank()
  ) +
  theme_classic() + 
  theme(
    text = element_text(size = 12),
    legend.position = 'bottom'
  )

Wir haben drei verschiedene Datenreduktionen vorgenommen. Das Ziel dieser Datenreduktionen war es den Datensatz auf verschiedene Weisen auf 400 Kunden und 700 Filme zu reduzieren. Die random_reduction reduziert den Datensatz auf eine zufällige Weise. Die 400 Kunden und die 700 Filme werden dabei also rein zufällig ausgewählt. Dabei bleibt die Sparcity praktisch unverändert. Sie sinkt von 93.67% auf 92.75%. Die dense_user_reduction reduziert die Filme immernoch zufällig, jedoch werden hier die 400 Kunden mit den meisten Bewertungen genutzt. Für diese Datenreduktion sinkt die Sparsity von 93.67% auf 88.18%. Die dense_reduction nimmt die 400 Kunden mit den meisten Bewertungen und die 700 Meistbewerteten Filme. Dies senkt die Sparcity von 93.67% auf 75.80%.

p1 <- image(dense_reduction, main = "Raw Ratings for Dense Reduction")
p2 <- image(dense_user_reduction, main = "Raw Ratings for Dense User Reduction")
p3 <- image(random_reduction, main = "Raw Ratings for Random Reduction")

grid.arrange(p1, p2, p3, ncol = 3, nrow = 1)

Hier Kann man noch die verschiedenen Matrizen der drei Datenreduktionen sehen. Es fällt auch hier klar auf, dass die Density der dense_reduction am grössten ist, die Matrix also klar am wenigsten Sparce ist. Auch die dense_user_reduction hat hier um einiges mehr gefüllte Zellen als die Matrix der random_reduction.

p1 <- show_change_of_rating_distribution(MovieLense, dense_reduction, 'Für dense_reduction, N alte Matrix = 1664 Filme, N neue Matrix = 700 Filme')
p2 <- show_change_of_rating_distribution(MovieLense, dense_user_reduction, 'Für dense_user_reduction, N alte Matrix = 1664 Filme, N neue Matrix = 700 Filme')
p3 <- show_change_of_rating_distribution(MovieLense, random_reduction, 'Für random_reduction, N alte Matrix = 1664 Filme, N neue Matrix = 700 Filme')

grid.arrange(p1, p2, p3, ncol = 2, nrow = 2)

Auf dieser Grafik ist die Veränderung der Verteilung der Bewertungen für die verschiedenen Datenreduktionen zu sehen. Die Verteilung der Bewertungen verändert sich nur für die dense_reduction signifikant. Bei dieser Datenreduktion werden die Filme ausgewählt, welche am meisten Bewertungen erhalten haben. Somit ist es logisch, dass auch die durchschnittliche Bewertung dabei steigt. Dies haben wir schon in der explorativen Datenanalyse herausgefunden.

---

Analyse Ähnlichkeitsmatrix

1. Zerlege den reduzierten MovieLense Datensatz in ein disjunktes Trainings- und Testdatenset im Verhältnis 4:1

#both <- split_dataset(ratingMatrix, 0.8)
#train <- both[[1]]
#test <- both[[2]]

#print('Trainingsdatenset:')
#dim(train)
#print('')
#print('Testdatenset:')
#dim(test)

e <- evaluationScheme(dense_reduction, method="split", train=0.8, k=1, given=0)

The following users do not have enough items leaving no given items: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122, 123, 124, 125, 126, 127, 128, 129, 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, 168, 169, 170, 171, 172, 173, 174, 175, 176, 177, 178, 179, 180, 181, 182, 183, 184, 185, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 208, 209, 210, 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, 221, 222, 223, 224, 225, 226, 227, 228, 229, 230, 231, 232, 233, 234, 235, 236, 237, 238, 239, 240, 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, 255, 256, 257, 258, 259, 260, 261, 262, 263, 264, 265, 266, 267, 268, 269, 270, 271, 272, 273, 274, 275, 276, 277, 278, 279, 280, 281, 282, 283, 284, 285, 286, 287, 288, 289, 290, 291, 292, 293, 294, 295, 296, 297, 298, 299, 300, 301, 302, 303, 304, 305, 306, 307, 308, 309, 310, 311, 312, 313, 314, 315, 316, 317, 318, 319, 320, 321, 322, 323, 324, 325, 326, 327, 328, 329, 330, 331, 332, 333, 334, 335, 336, 337, 338, 339, 340, 341, 342, 343, 344, 345, 346, 347, 348, 349, 350, 351, 352, 353, 354, 355, 356, 357, 358, 359, 360, 361, 362, 363, 364, 365, 366, 367, 368, 369, 370, 371, 372, 373, 374, 375, 376, 377, 378, 379, 380, 381, 382, 383, 384, 385, 386, 387, 388, 389, 390, 391, 392, 393, 394, 395, 396, 397, 398, 399, 400

train <- getData(e, "train")
test <- getData(e, 'unknown')

TODO: ignore warning + evtl. löschen?

---

2. Trainiere ein IBCF Modell mit 30 Nachbarn und Cosine Similarity

# train IBCF recommender
rec <- Recommender(train, method = "IBCF", param=list(method="Cosine", k=30, normalize = NULL, na_as_zero = TRUE)) #normalize = 'center'
# predict top 10 movies for 100 users
pre <- predict(rec, test, n = 10)

---

3. Bestimme die Verteilung der Filme, welche bei IBCF für paarweise Ähnlichkeitsvergleiche verwendet werden

model <- getModel(rec)
colSum <- colSums(model$sim > 0)

df <- as.data.frame(colSum)

# add index column
df <- cbind(item = rownames(df), df)
rownames(df) <- 1:nrow(df)

ggplot(df, aes(x = colSum)) +
  geom_histogram(alpha = 1, fill = 'steelblue', binwidth = 2) +
  scale_y_continuous(expand = c(0,0)) +
  scale_x_continuous(expand = c(0,0)) +
  labs(
    title = "Verteilung der Anzahl ähnlicher Filme",
    # subtitle = paste("N = ", nrow(df3), " Filme"),
    x = "Anzahl Filme bei denen der Film als Nachbar auftaucht", 
    y = "Häufigkeit"
  ) +
  theme_classic() +
  theme(text = element_text(size = 12)
  )

Diese Grafik zeigt auf wie oft ein Film in der Nachbarschaft eines anderen Filmes auftaucht. Zu sehen ist also die Ähnlichkeit der einzelnen Filme, wobei zu erkennen ist, dass viele Filme bei wenigen anderen Items in der Nachbarschaft auftauchen und wenige Filme bei sehr vielen Items auftauchen.

---

4. Bestimme die Filme, die am häufigsten in der Cosine-Ähnlichkeitsmatrix auftauchen und analysiere deren Vorkommen und Ratings im reduzierten Datensatz

df1 <- df %>% arrange(desc(colSum)) %>% head(10)

ggplot(df1, aes(x = colSum, y = reorder(item, +colSum)))+
  geom_col(alpha = 1, fill = 'steelblue')+
  scale_y_discrete(expand = c(0,0)) +
  scale_x_continuous(expand = c(0,0)) +
  geom_text(aes(label=round(colSum,2)), hjust = 1.3, color = 'white') +
  labs(
    title = "Häufigste Filme in Cosine-Ähnlichkeitsmatrix",
    y = element_blank(),
    x = "Anzahl Filme in deren Nachbarschaft der Film ist"
  ) +
  theme_classic() +
  theme(axis.text.x = element_blank(),
        axis.ticks.x = element_blank(),
        axis.line.x = element_blank(),
        text = element_text(size = 12) # text size
  )

Hier sind die Filme welche am häufigsten in Nachbarschaften anderer Filme auftauchen aufgelistet. Die beiden Filme welche am häufigsten in dieser Matrix auftauchen sind zwei Filme aus der Star Wars Reihe.

top10 <- as.list(df1)$item

data <- as(ratingMatrix, "data.frame")
data1 <- data %>%
  group_by(item) %>%
  summarize(mean_rating = mean(rating)) %>%
  arrange(desc(mean_rating)) %>%
  mutate(category = ifelse(item %in% top10, 'Häufigste 10 Filme', 'Restliche Filme'))

ggplot(data1, aes(x = mean_rating, fill = category)) +
  geom_density(alpha = 0.5, bw = 0.05) +
  scale_y_continuous(expand = c(0,0)) +
  scale_x_continuous(expand = c(0,0)) +
  labs(
    title = "Verteilung mittlere Kundenratings pro Film",
    x = "Durchschnittliche Bewertung",
    y = "Dichte",
    fill = element_blank()
  ) +
  theme_classic() +
  theme(
    text = element_text(size = 12),
    legend.position = c(.14, .93)
  )

Hier werden die durchschnittlichen Bewertungen der Filme welche am häufigsten in der Ähnlichkeitsmatrix auftauhen mit den restlichen filmen verglichen. Auch hier fällt erneut auf, dass die häufigsten Filme allgemein sehr gut bewertet wurden.

---

##Analyse Top-N Listen - IBCF vs. UBCF ####1.Berechne Top-15 Empfehlungen für Testkunden mit IBCF und UBCF

rec_ibcf <- Recommender(train, method = "IBCF", param=list(method="Cosine", k=30, normalize = NULL, na_as_zero = TRUE))
topn_ibcf <- predict(rec_ibcf, test, n = 15)
topn_ibcf_list <- as(topn_ibcf, "list")
topn_ibcf_df <- as.data.frame(do.call(rbind, topn_ibcf_list))

rec_ubcf <- Recommender(train, method = "UBCF", param=list(method="Cosine", normalize = NULL))
topn_ubcf <- predict(rec_ubcf, test, n = 15)
topn_ubcf_list <- as(topn_ubcf, "list")
topn_ubcf_df <- as.data.frame(do.call(rbind, topn_ubcf_list))

---

####2.Vergleiche die Top-15 Empfehlungen und deren Verteilung und diskutiere Gemeinsamkeiten und Unterschiede zwischen IBCF und UBCF für alle Testkunden.

#compare most occurring items

ibcf_top <- head(sort(colCounts(topn_ibcf), decreasing = TRUE))
ibcf_top_df <- as.data.frame(ibcf_top)
ibcf_top_df <- tibble::rownames_to_column(ibcf_top_df, "movies")
names(ibcf_top_df)[names(ibcf_top_df) == 'ibcf_top'] <- 'n_appearances'


ubcf_top <- head(sort(colCounts(topn_ubcf), decreasing = TRUE))
ubcf_top_df <- as.data.frame(ubcf_top)
ubcf_top_df <- tibble::rownames_to_column(ubcf_top_df, "movies")
names(ubcf_top_df)[names(ubcf_top_df) == 'ubcf_top'] <- 'n_appearances'

p1 <- plot_most_occ_item(ibcf_top_df, 'ibcf')
p2 <- plot_most_occ_item(ubcf_top_df, 'ubcf')

grid.arrange(p1, p2, ncol = 2, nrow = 1)

Auffällig ist, dass im UBCF die Filme, welche am häufigsten in den Top-15 Empfehlungen auftauchen, wesentlich öfters vorkommen als diese, die im IBCF als am meist vorkommende Filme definiert sind. Ebenfalls auffallend ist, dass die beiden Recommender sehr verschiedene Vorschläge generieren. Für die meist vorkommenden Filme in den TopNListen gibt es hier keine Überschneidung.

#get distribution of intersect for each user
#intersect of top 15 recommendations IBCF vs UBCF
#list_comp_ibcf_ubcf <- vector(mode = "list", length = length(topn_ibcf_list))
list_comp_ibcf_ubcf <- list()
for (n in 1:length(topn_ibcf_list)) {
  intersection <- length(intersect(unlist(topn_ibcf_list[n]), unlist(topn_ubcf_list[n]))) / 15
  list_comp_ibcf_ubcf <- append(list_comp_ibcf_ubcf, intersection)
}

comp_ibcf_ubcf <- data.frame(matrix(unlist(list_comp_ibcf_ubcf), nrow=length(list_comp_ibcf_ubcf), byrow=TRUE))
colnames(comp_ibcf_ubcf) <- c('intersect')
comp_ibcf_ubcf <- comp_ibcf_ubcf %>% group_by(intersect) %>% summarise(count = n()) %>% ungroup()
comp_ibcf_ubcf$intersect <- as.character(round(comp_ibcf_ubcf$intersect, 2))

ggplot(comp_ibcf_ubcf, aes(x = intersect, y = count)) +
  geom_col(alpha = 1, fill = 'steelblue') +
  geom_text(aes(label=count), vjust=-.5, color = 'black') +
  scale_y_continuous(limits = c(0,37),expand = c(0,0)) +
  labs(
    title = "Verteilung der überschneidung der empfohlenen Filme",
    # subtitle = paste("N = ", nrow(df3), " Filme"),
    x = "Überschneidung in %", 
    y = "Häufigkeit"
  ) +
  theme_classic() +
  theme(text = element_text(size = 12)
  )

hier ist die Übrschneidung der beiden Recommender (IBCF & UBCF) auf alle User zu sehen. Klar zu erkennen ist, dass auch auf alle User betrachtet keine grossen übereinstimmungen der Vorschläge zu sehen ist.

---

Analyse Top-N Listen - Ratings

Vergleiche den Anteil übereinstimmender Empfehlungen der Top-15 Liste für IBCF vs UBCF, beide mit ordinalem Rating und Cosine Similarity für alle Testkunden

datasets = c(dense_reduction, dense_user_reduction, random_reduction)
datasetnames = c('dense_reduction', 'dense_user_reduction', 'random_reduction')

p1 <- intersect_ibcf_ubcf(dense_reduction, 'dense_reduction')

The following users do not have enough items leaving no given items: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122, 123, 124, 125, 126, 127, 128, 129, 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, 168, 169, 170, 171, 172, 173, 174, 175, 176, 177, 178, 179, 180, 181, 182, 183, 184, 185, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 208, 209, 210, 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, 221, 222, 223, 224, 225, 226, 227, 228, 229, 230, 231, 232, 233, 234, 235, 236, 237, 238, 239, 240, 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, 255, 256, 257, 258, 259, 260, 261, 262, 263, 264, 265, 266, 267, 268, 269, 270, 271, 272, 273, 274, 275, 276, 277, 278, 279, 280, 281, 282, 283, 284, 285, 286, 287, 288, 289, 290, 291, 292, 293, 294, 295, 296, 297, 298, 299, 300, 301, 302, 303, 304, 305, 306, 307, 308, 309, 310, 311, 312, 313, 314, 315, 316, 317, 318, 319, 320, 321, 322, 323, 324, 325, 326, 327, 328, 329, 330, 331, 332, 333, 334, 335, 336, 337, 338, 339, 340, 341, 342, 343, 344, 345, 346, 347, 348, 349, 350, 351, 352, 353, 354, 355, 356, 357, 358, 359, 360, 361, 362, 363, 364, 365, 366, 367, 368, 369, 370, 371, 372, 373, 374, 375, 376, 377, 378, 379, 380, 381, 382, 383, 384, 385, 386, 387, 388, 389, 390, 391, 392, 393, 394, 395, 396, 397, 398, 399, 400

p2 <- intersect_ibcf_ubcf(dense_user_reduction, 'dense_user_reduction')

The following users do not have enough items leaving no given items: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122, 123, 124, 125, 126, 127, 128, 129, 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, 168, 169, 170, 171, 172, 173, 174, 175, 176, 177, 178, 179, 180, 181, 182, 183, 184, 185, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 208, 209, 210, 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, 221, 222, 223, 224, 225, 226, 227, 228, 229, 230, 231, 232, 233, 234, 235, 236, 237, 238, 239, 240, 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, 255, 256, 257, 258, 259, 260, 261, 262, 263, 264, 265, 266, 267, 268, 269, 270, 271, 272, 273, 274, 275, 276, 277, 278, 279, 280, 281, 282, 283, 284, 285, 286, 287, 288, 289, 290, 291, 292, 293, 294, 295, 296, 297, 298, 299, 300, 301, 302, 303, 304, 305, 306, 307, 308, 309, 310, 311, 312, 313, 314, 315, 316, 317, 318, 319, 320, 321, 322, 323, 324, 325, 326, 327, 328, 329, 330, 331, 332, 333, 334, 335, 336, 337, 338, 339, 340, 341, 342, 343, 344, 345, 346, 347, 348, 349, 350, 351, 352, 353, 354, 355, 356, 357, 358, 359, 360, 361, 362, 363, 364, 365, 366, 367, 368, 369, 370, 371, 372, 373, 374, 375, 376, 377, 378, 379, 380, 381, 382, 383, 384, 385, 386, 387, 388, 389, 390, 391, 392, 393, 394, 395, 396, 397, 398, 399, 400

p3 <- intersect_ibcf_ubcf(random_reduction, 'random_reduction')

The following users do not have enough items leaving no given items: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122, 123, 124, 125, 126, 127, 128, 129, 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, 168, 169, 170, 171, 172, 173, 174, 175, 176, 177, 178, 179, 180, 181, 182, 183, 184, 185, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 208, 209, 210, 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, 221, 222, 223, 224, 225, 226, 227, 228, 229, 230, 231, 232, 233, 234, 235, 236, 237, 238, 239, 240, 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, 255, 256, 257, 258, 259, 260, 261, 262, 263, 264, 265, 266, 267, 268, 269, 270, 271, 272, 273, 274, 275, 276, 277, 278, 279, 280, 281, 282, 283, 284, 285, 286, 287, 288, 289, 290, 291, 292, 293, 294, 295, 296, 297, 298, 299, 300, 301, 302, 303, 304, 305, 306, 307, 308, 309, 310, 311, 312, 313, 314, 315, 316, 317, 318, 319, 320, 321, 322, 323, 324, 325, 326, 327, 328, 329, 330, 331, 332, 333, 334, 335, 336, 337, 338, 339, 340, 341, 342, 343, 344, 345, 346, 347, 348, 349, 350, 351, 352, 353, 354, 355, 356, 357, 358, 359, 360, 361, 362, 363, 364, 365, 366, 367, 368, 369, 370, 371, 372, 373, 374, 375, 376, 377, 378, 379, 380, 381, 382, 383, 384, 385, 386, 387, 388, 389, 390, 391, 392, 393, 394, 395, 396, 397, 398, 399, 400

grid.arrange(p1, p2, p3, ncol = 2, nrow = 2)

Hier wurden für die drei Datenreduktionen jeweils IBCF mit UBCF verglichen, mit Cosine und Jaccard similarity. Auffallend ist hier, dass die Datenreduktion keinen Einfluss auf den Anteil Übereinstimmung der Vorschläge hat. Zudem ist klar zu erkennen, dass UBCF mit Jaccard similarity verglichen mit UBCF mit Cosine Similarity die grösste übereinstimmung hat. Allerdings liegt auch diese Übereinstimmung nur bei ca. 12%. Sibald aber ein IBCF mit einem UBCF verglichen wird ist die Überinstimmung der vorgeschlagenen Items noch kleiner.

---

##Analyse Top-N Listen - IBCF vs SVD ####1.Vergleiche wie sich der Anteil übereinstimmender Empfehlungen der Top-15 Liste für IBCF vs verschiedene SVD Modelle verändert, wenn die Anzahl der Singulärwerte für SVD von 10 auf 20, 30, 40, 50 verändert wird

#dense_reduction, dense_user_reduction, random_reduction

datasets = c(dense_reduction, dense_user_reduction, random_reduction)
datasetnames = c('dense_reduction', 'dense_user_reduction', 'random_reduction')
k = c(10, 20, 30, 40, 50)
dense_reduction

400 x 700 rating matrix of class ‘realRatingMatrix’ with 67765 ratings.

output <- data.frame('comparison' = character(), 'intersection' = numeric(), 'dataset' = character())
colnames(output) <- c('comparison', 'intersection', 'dataset')

for (d in 1:length(datasets)){
  e <- evaluationScheme(datasets[[d]], method="split", train=0.8, k=1, given=0)
  train <- getData(e, "train")
  test <- getData(e, 'unknown')
  
  for (n in k){
    rec_svd <- Recommender(train, method = "SVD", param=list(k = n))
    topn_svd <- predict(rec_svd, test, n = 15)
    topn_svd_list <- as(topn_svd, "list")
  
    comp_ibcf_svd <- 0
    for (i in 1:length(topn_ibcf_list)) {
      intersection <- length(intersect(unlist(topn_ibcf_list[i]), unlist(topn_svd_list[i]))) / 15
      comp_ibcf_svd <- comp_ibcf_svd + intersection
    }
    out <- c(paste('IBCF vs. SVD', n), round(comp_ibcf_svd / length(topn_ibcf_list), digits = 4), as.character(datasetnames[[d]]))
    output[nrow(output) + 1,] = out
    }
}

The following users do not have enough items leaving no given items: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122, 123, 124, 125, 126, 127, 128, 129, 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, 168, 169, 170, 171, 172, 173, 174, 175, 176, 177, 178, 179, 180, 181, 182, 183, 184, 185, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 208, 209, 210, 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, 221, 222, 223, 224, 225, 226, 227, 228, 229, 230, 231, 232, 233, 234, 235, 236, 237, 238, 239, 240, 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, 255, 256, 257, 258, 259, 260, 261, 262, 263, 264, 265, 266, 267, 268, 269, 270, 271, 272, 273, 274, 275, 276, 277, 278, 279, 280, 281, 282, 283, 284, 285, 286, 287, 288, 289, 290, 291, 292, 293, 294, 295, 296, 297, 298, 299, 300, 301, 302, 303, 304, 305, 306, 307, 308, 309, 310, 311, 312, 313, 314, 315, 316, 317, 318, 319, 320, 321, 322, 323, 324, 325, 326, 327, 328, 329, 330, 331, 332, 333, 334, 335, 336, 337, 338, 339, 340, 341, 342, 343, 344, 345, 346, 347, 348, 349, 350, 351, 352, 353, 354, 355, 356, 357, 358, 359, 360, 361, 362, 363, 364, 365, 366, 367, 368, 369, 370, 371, 372, 373, 374, 375, 376, 377, 378, 379, 380, 381, 382, 383, 384, 385, 386, 387, 388, 389, 390, 391, 392, 393, 394, 395, 396, 397, 398, 399, 400The following users do not have enough items leaving no given items: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122, 123, 124, 125, 126, 127, 128, 129, 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, 168, 169, 170, 171, 172, 173, 174, 175, 176, 177, 178, 179, 180, 181, 182, 183, 184, 185, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 208, 209, 210, 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, 221, 222, 223, 224, 225, 226, 227, 228, 229, 230, 231, 232, 233, 234, 235, 236, 237, 238, 239, 240, 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, 255, 256, 257, 258, 259, 260, 261, 262, 263, 264, 265, 266, 267, 268, 269, 270, 271, 272, 273, 274, 275, 276, 277, 278, 279, 280, 281, 282, 283, 284, 285, 286, 287, 288, 289, 290, 291, 292, 293, 294, 295, 296, 297, 298, 299, 300, 301, 302, 303, 304, 305, 306, 307, 308, 309, 310, 311, 312, 313, 314, 315, 316, 317, 318, 319, 320, 321, 322, 323, 324, 325, 326, 327, 328, 329, 330, 331, 332, 333, 334, 335, 336, 337, 338, 339, 340, 341, 342, 343, 344, 345, 346, 347, 348, 349, 350, 351, 352, 353, 354, 355, 356, 357, 358, 359, 360, 361, 362, 363, 364, 365, 366, 367, 368, 369, 370, 371, 372, 373, 374, 375, 376, 377, 378, 379, 380, 381, 382, 383, 384, 385, 386, 387, 388, 389, 390, 391, 392, 393, 394, 395, 396, 397, 398, 399, 400The following users do not have enough items leaving no given items: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122, 123, 124, 125, 126, 127, 128, 129, 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, 168, 169, 170, 171, 172, 173, 174, 175, 176, 177, 178, 179, 180, 181, 182, 183, 184, 185, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 208, 209, 210, 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, 221, 222, 223, 224, 225, 226, 227, 228, 229, 230, 231, 232, 233, 234, 235, 236, 237, 238, 239, 240, 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, 255, 256, 257, 258, 259, 260, 261, 262, 263, 264, 265, 266, 267, 268, 269, 270, 271, 272, 273, 274, 275, 276, 277, 278, 279, 280, 281, 282, 283, 284, 285, 286, 287, 288, 289, 290, 291, 292, 293, 294, 295, 296, 297, 298, 299, 300, 301, 302, 303, 304, 305, 306, 307, 308, 309, 310, 311, 312, 313, 314, 315, 316, 317, 318, 319, 320, 321, 322, 323, 324, 325, 326, 327, 328, 329, 330, 331, 332, 333, 334, 335, 336, 337, 338, 339, 340, 341, 342, 343, 344, 345, 346, 347, 348, 349, 350, 351, 352, 353, 354, 355, 356, 357, 358, 359, 360, 361, 362, 363, 364, 365, 366, 367, 368, 369, 370, 371, 372, 373, 374, 375, 376, 377, 378, 379, 380, 381, 382, 383, 384, 385, 386, 387, 388, 389, 390, 391, 392, 393, 394, 395, 396, 397, 398, 399, 400

output

ggplot(output, aes(x = comparison, y = intersection, fill = dataset)) +
  geom_col(alpha = 1, position = position_dodge()) +
  #geom_text(aes(label=count), vjust=1.5, color = 'white') +
  scale_y_discrete(expand = c(0,0)) +
  labs(
    title = "Überschneidung der Vorschläge SVD und IBCF Recommender",
    # subtitle = paste("N = ", nrow(df3), " Filme"),
    x = "verglichene Recommender", 
    y = "Anteil Überschneidung in %"
  ) +
  theme_classic() +
  theme(text = element_text(size = 12),
        axis.text.x = element_text(angle = 60, hjust = 1)
  )

Auch hier werden die vorgeschlagenen Items von verschiedenen Recommendern verglichen. Diesmal SVD Recommender mit verschiedenen Singulärvektoren und IBCF. AUch dies wird wieder mit den verschiedenen Datenreduktionen verglichen. Hier zu sehen ist klar, dass die Datenreduktion durchaus einfluss auf die Überschneidung der vorgeschlagenen Items hat. Jedoch wenn die skala bei Anteil Überschneidung betrachtet wird, ist zu erkennen, dass dieser Einfluss in einem sehr kleinen bereich liegt. zu erkennen ist, dass IBCF mit SVD verglichen sehr kleine Überschneidungen produziert. Wenn man die dense_reduction und die random_reduction betrachtet ist eine tendenz zu erkennen, dass bei einer steigerung der Anzahl Singulärvektoren auch eine grössere Überschneidung erzielt wird.

---

Wahl des optimalen Recommenders

Verwende für die Evaluierung 10-fache Kreuzvalidierung,

Für die Evaluierung und Optimierung wurden die dense reduzierten Datensätze verwendet. Dies, da alle items in der Matrix mehr Einträge haben müssen als im given_n spezifiziert. Die Reduzierung dieses Parameters würde wiederum zu veränderten Resultaten führen.

Als erstes stellte sich die Frage, ob precision, recall, oder ein kombinierter F1-Score als performance Metrik gewählt werden sollte. Precision ist umgekehrt proportional zu false positive, recall zu false negative Voraussagen. Da es in diesem Fall wichtiger ist, die gemachten Empfehlungen korrekt vorauszusagen, wurde Precision als Performance Metrik definiert. Als zweite Wahl würden wir auf den F1-Score zurückgreifen. Dieser setzt sich aus der Kombination beider Metriken precision und recall zusammen.

Der Parameter goodRating stellt die binäre Grenze dar, bei welcher ein Rating als “positiv” bezeichnet werden kann. Wird der Wert höher gesetzt, sinkt die Precision und der Recall steigt. In dieser Modelloptimierung wurde definiert, dass alle Ratings ab 3 als positiv klassifiziert werden sollten.

In dieser Grafik ist die Precision der Novelty der trainierten Modelle gegenübergestellt. Dabei wurde jedes Modell für n-recommendations trainiert und dargestellt. Es wurde 10 fold cross validation verwendet. Die dargestellten Werte visualisieren das arithmetische Mittel der Scores auf den jeweils 10 Testdatensätzen. Dadurch können die Modelle und Parameter unabhängig von der Struktur der Daten miteinander verglichen werden.

Als erstes wurde sichtbar, dass die Modellwahl mehr Einfluss auf die Precision des Modells hatte als die n-recommendations. Deshalb wurde nur SVD und popular für weitere Hyperparameteroptimierung angeschaut.

Das SVD Modell wurde hier für verschiedene k’s trainiert. Dabei wurde klar, dass ein k~5 die beste Precision voraussagt. Jedoch kommt das Modell nicht annähernd an die Precision von popular heran.

Das beste daraus resultierende Modell ist in dem Falle “popular items” mit n=10 Voraussagen.

Das popular Modell besitzt keine Hyperparameter für die Optimierung. Deshalb wird hier SVD bezüglich Hyperparameter k und n im Detail optimiert.

Für das Modell SVD ist die Precision am besten, wenn k=4 ist und n=10. Zudem wurde festgestellt, dass je nach Seed Position k=5 besser sein kann. Die Precision des Modells mit optimierten Hyperparametern ist immernoch tiefer, als die des popular Modells.

---

Implementierung Ähnlichkeitsmatrix

Als erstes wird hier ein sample aus 100 zufällig gewähten Filmen gezogen.

# reduce samples to 100 users
sample_sim <- sample_similarity(movies)
# generate matrix equivalent
sample_sim_matrix <- as(sample_sim, 'matrix')
# convert back to real rating matrix
sample_sim_rating <- as(sample_sim, "realRatingMatrix")
sample_sim_rating_norm <- normalize(sample_sim_rating)
sample_sim_wide_norm <- as(sample_sim_rating_norm, 'matrix')
# create wide versionwide version
sample_sim_wide <- pivot_wider(
  sample_sim,
  id_cols = user,
  names_from = item,
  values_from = rating,
  values_fill = NULL,
)

sample_sim_wide

Hier wird ein IBCF recommender gebaut, um die Cosinesimilarity Matrix der Filme mithilfe von Recommenderlab zu erstellen. Dabei wurden folgende Parameter eingestellt: - k: in Recommenderlab wird die Similarity zu k-Nachbaren berechnet. Damit die Implementierung mit der eigenen übereinstimmen kann, muss dieser Wert gleich gross oder grösser als die Anzahl Items in den Daten sein. Da wir 100 Filme ausgewählt haben, wird k=100 gewählt.

• normalize: Recommenderlab normalisiert die Ratings standardmässig. Damit dies mit der eigenen Implementierung übereinstimmt, wird die Normalisierung hier deaktiviert.

• na_as_zero: NA’s werden in Recommenderberechnungen standardmässig ausgelassen. Da in der eigenen Imeplentierung die NA’s auch auf 0 gesetzt werden, wurde dies hier auch gemacht. Hätte noch eine Normalisierung stattgefunden, wäre dies beispielsweise bei normalize=‘center’ der Mittelwert.

k_value = dim(sample_sim_rating)[2]
#print(paste("K-Wert: ", k_value))

start.time <- Sys.time()
rec <- Recommender(sample_sim_rating, method = "IBCF", param=list(method="Cosine", k=k_value, normalize = NULL, na_as_zero = TRUE))
end.time <- Sys.time()
elapsed.time <- round((end.time - start.time), 3)
print(elapsed.time)

similarity <- as.matrix(rec@model$sim)
#image(similarity)
plot_sim(similarity, "IBCF cosine similarity matrix")

Es wird sichtbar, dass die Diagonalwerte eine andere Farbe aufweisen. Leider kann man die Similarities aufgrund der Menge von Datenpunkten nicht wirklich vergleichen. Werden die ersten Werte visualisiert, wird jedoch klar dass die Diagonaleinträge 0 anstatt 1 sind. Dies ist jedoch nicht weiter tragisch, da diese Daten keine Informationen tragen. Sie können deshalb ignoriert werden.

similarity[1:3, 1:3]

# sort colums alphabetical without user column indexes
sample_sim_zero <- sample_sim_wide[-1][, order(colnames(sample_sim_wide[-1])),]
# convert to matrix
sample_sim_zero <- as(sample_sim_zero, 'matrix')
# replace nas with 0 (non adjusted cosine similarity)
sample_sim_zero[is.na(sample_sim_zero)] <- 0

start.time <- Sys.time()
cosine_sim_matrix <- cosine_sim2(t(sample_sim_zero), t(sample_sim_zero))
end.time <- Sys.time()
elapsed.time <- round((end.time - start.time), 3)
print(elapsed.time)

plot_sim(cosine_sim_matrix, "IBCF cosine similarity matrix")

Hier wurde die Cosinesimilarity als Matrixberechnung implementiert. Der Zeitaufwand der Berechnung ist etwas geringer als bei der Implementierung von Recommenderlab. Dies ist der Fall, da im Recommenderlabpackage noch weitere Schritte durchlaufen werden, um beispielsweise für k-Nachbaren zu optimieren. Wie man erkennen kann, sind die Ausprägungen der Similarities ähnlich zur Recommenderlab Implementierung, bis auf die Diagonalwerte. Diese werden deshalb noch durch 0 ersetzt.

diag(cosine_sim_matrix) <- 0
cosine_sim_matrix[1:3, 1:3]

Auch die ersten Zahlenwerte stimmen mit dem Print der Similarities von Recommenderlab überein.

Nun werden die Zahlenwerte der zwei berechneten Similaritymatrizen verglichen.

sum(abs(cosine_sim_matrix - similarity))

Wie hier sichtbar wird, ist die Summe der absoluten Differenzen aller Werte der Matrizen verschwindend klein. Die Matrizen sind also bis auf den Fliesskommafehler identisch.

Als nächstes wird die Jaccard Similarity berechnet. Dafür werden die Ratings zuerst binärisiert. Als Splitkriterium wurde ein Rating von 3 gewählt was bedeutet, dass alle Ratings ab 3 als True dargestellt werden, alle Ratings darunter als False.

# binarize matrix and make split at a rating of 3
sample_sim_bin <- as(binarize(as(sample_sim_rating, "realRatingMatrix"), minRating=3), "matrix") * 1

start.time <- Sys.time()
jac_own <- jaccard_sim2(t(sample_sim_bin), t(sample_sim_bin))
end.time <- Sys.time()
elapsed.time <- round((end.time - start.time), 3)
print(elapsed.time)

plot_sim(jac_own, "IBCF jaccard similarity matrix")

#dim(wide_matrix)

jac_own[1:3, 1:3]

Auch bei der Implementierung der Jaccard Similarity ist dank Matriximplementation der Zeitaufwand relativ gering. Hier fällt jedoch auf, dass auf der Diagonalen Lücken (0-Werte) anstatt 1er bestehen. Ein Beispiel wurde hier herausgesucht:

print(paste("NA value count in similarity matrix:", sum(is.na(jac_own))))
jac_own[43:45, 43:45]
jac_own[38:40, 38:40]

print(paste(sum(sample_sim_bin[,44]), "people have rated <Homage (1995)> 3 or higher."))
print(paste(sum(sample_sim_bin[,39]), "people have rated <Gordy (1995)> 3 or higher."))

Bei Durchsuchung des Datensatzes ist auffallend, dass diese Filme nur binärisiert-nagative Bewertungen enthalten. Durch die Implementierung der Jaccard Similarity entsteht dadurch im Nenner eine 0, was zu einer Jaccard Similarity von NA führt.

Als Nächstes wird die normierte Cosine Ähnlichkeitsmatrix berechnet.

mean_total <- mean(sample_sim_wide_norm, na.rm=TRUE)

for(col_i in 1:dim(sample_sim_wide_norm)[2])
{
  # replace nas with 0 (non adjusted cosine similarity)
  mean_col = mean(sample_sim_wide_norm[,col_i], na.rm=TRUE)
  #print(mean_col)
  sample_sim_wide_norm[is.na(sample_sim_wide_norm[,col_i]), col_i] <- mean_col

}

start.time <- Sys.time()
cosine_sim_norm <- cosine_sim2(t(sample_sim_wide_norm), t(sample_sim_wide_norm))
end.time <- Sys.time()
elapsed.time <- round((end.time - start.time), 3)
print(elapsed.time)

plot_sim(cosine_sim_norm, "IBCF cosine similarity matrix normiert")

In dieser Darstellung ist die normierte Cosine Similarity dargestellt. Für die Normierung wurde min-max Normailisierung gewählt, mit dem Mittelwert der Ratings pro Film als NA Ersatz. Dadurch entsteht wie erwartet grundsätzlich eine höhere Similarity, wessen Werte sich zwischen 0 und 1 ansiedeln.

p1 <- plot_sim(cosine_sim_matrix, "IBCF cosine similarity matrix")
p2 <- plot_sim(jac_own, "IBCF jaccard similarity matrix")
p3 <- plot_sim(cosine_sim_norm, "IBCF cosine similarity matrix normiert")

grid.arrange(p1, p2, p3, ncol = 3, nrow = 1)

Die unnormalisierten Cosine und Jaccard Ähnlichkeitsmatrizen sind sich sehr ähnlich. Sie weisen ähnliche strukturelle Eigenschaften auf. Die Jaccard Ähnlichkeitsmatrix enthält generell etwas tiefere Werte und ist deshalb heller. Es werden jedoch einzelne Punkte sichtbar, welche eine Ähnlichkeit von 1 aufweisen.

#print(jac_own[25:28, 25:27])
subset <- sample_sim_wide[, c('Designated Mourner, The (1997)', 'Dadetown (1995)')]

colSums(!is.na(subset))

Dies ist beispielsweise bei den Filmen ‘Designated Mourner, The (1997)’ und ‘Dadetown (1995)’ der Fall. Diese Filme wurde drei, bzw. ein Mal bewertet. Der Rest der Werte ist jeweils auf 0 gesetzt. Deshalb wird die Cosine Ähnlichkeit zwischen diesen Werten kaum aussagekräftig sein. Diese Werte sind deshalb von niedriger Bedeutung.

Die normalisierte Cosine Ähnlichkeitsmatrix ist etwas anders in der Struktur. Dadurch, dass die Mittelwerte der jeweiligen Filmbewertungen durch die fehlenden Daten ein hohes Gewicht auf die Daten haben, entstehen generell grössere Abstände zwischen den Bewertungen einzelner Filme. Diese werden sichtbar durch Streifen. Dadurch liegt ein stärkerer Fokus auf den Unterschieden der Filmbewertungen im Allgemeinen und weniger auf den Unterschieden einzelner Ratings. Dadurch verschwinden die Similarities einzelner Filme ein wenig und die Grafik ist schwerer zu lesen. Wäre die Matrix weniger sparce, würde diese Impuation nicht so stark ins Gewicht fallen und die Darstellung könnte besser abgelesen werden. In diesem Falle ist diese Grafik jedoch nicht gut geeignet.

---

Implementierung Top-N Metriken

Catalog coverage and System-level novelty

rec <- Recommender(train, method = "IBCF", param=list(method="Cosine", k=30, normalize = NULL, na_as_zero = TRUE)) #normalize = 'center', 'Z-score'

df_coverage <- show_coverage(c(5,10,15,20,25,30), rec)
df_novelty <- show_novelty(c(5,10,15,20,25,30))

df_combined <- inner_join(df_coverage, df_novelty, by = 'N')

Coverage: Summe aller unterschiedlichen Produkte, welche in den Top-N Listen aller KundInnen insgesamt auftauchen dividiert durch die Menge aller Produkte. Novelty: Mittel der Shannon Information der Popularität der Produkte in der Top-N Liste gemittelt über alle KundInnen.

ggplot(data=df_combined, aes(x=coverage, y=novelty, group=1)) +
  geom_line() +
  geom_text(aes(label=N), vjust=-.25, hjust=-.05, show.legend = FALSE) +
  labs(
    title = "Coverage gegenüber Novelty für verschiedene N",
    y = "Novelty",
    x = "Coverage"
  ) +
  theme(text = element_text(size = 12))

TODO: das ganze im selben plot für verschiedene reduktionen darstellen + text + verschiedene Datenreduktionen

---

Implementierung Top-N Monitor

Fixiere 20 zufällig gewählte Testkunden für alle Modellvergleiche

Bestimme den Anteil der Top-N Empfehlung nach Genres pro Kunde

TODO: Hier auch 3 mal? - nein TODO: IBCF im titel erwähnen

rec <- Recommender(train, method = "IBCF", param=list(method="Cosine", k=30, normalize = NULL, na_as_zero = TRUE))
df_user_genres_top_n <- create_df_user_genres_top_n(rec, genres)
show_genre_fraction_plot(df_user_genres_top_n, df_user_genres_top_n$count_top_n, "Anteil Genres in Top-N Empfehlung von 20 zuf. Kunden")

Auf diesem Plot ist die Unterschiedliche Verteilung der Genres in den Top-N Empfehlungen für die verschiedenen Kunden zu sehen. Es fällt auf, dass bei diesem Recommender durchaus verschiedenartige Verteilungen bei den Genres für die verschiednen Nutzer auftreten.

Bestimme pro Kunde den Anteil nach Genres seiner Top-Filme (=Filme, welche vom Kunden die besten Bewertungen erhalten haben)

df_user_genres_best <- create_df_user_genres_best(movies, df_user_genres_top_n, genres)
show_genre_fraction_plot(df_user_genres_best, df_user_genres_best$count_best, "Anteil Genres der bestbewerteten Filme von 20 zuf. Kunden")

Auf diesem Plot ist die unterschiedliche Verteilung der Genres bei den bestbewerteten Filmen für die verschiedenen Kunden zu sehen. Best bewertet bedeutet in diesem Fall, dass die Bewertung eines Filmes mindestens 0.5 höher sein muss, als die Durchschnittliche Bewertung des Nutzers. Es fällt auf, dass bei den Top-N Empfehlungen allgemein Action zu wenig empfohlen wurde. Comedy hingegen wurde häufig zu viel empfohlen. Bei genauerem betrachten fällt auf, dass dieser Recommeder beispielsweise bei Kunde Nr. 38 auf die Genres bezogen relativ schlechte Empfehlungen macht.

Vergleiche pro Kunde Top-Empfehlungen und Top-Filmen nach Genres

df_user_genres_best <- create_df_user_genres_best(movies, df_user_genres_top_n, genres)

rec <- Recommender(train, method = "IBCF", param=list(method="Cosine", k=30, normalize = NULL, na_as_zero = TRUE))
df_user_genres_top_n <- create_df_user_genres_top_n(rec, genres)
df_user_genres <- create_df_user_genres(df_user_genres_top_n, df_user_genres_best)
show_cleveland_dot_plot(df_user_genres, 'IBCF Recommender mit Cosine Similarity')

Auf diesem Plot ist ersichtlich welche Genres der IBCF Recommender mit Cosine Similarity für die 20 Kunden eher zu wenig oder zu viel empfiehlt. Beispielsweise Comedy macht bei den bestbewerteten Filmen im Durchschnitt ungefähr 12% aus, erscheint in den Top-N Empfehlungen jedoch zu etwa 21%.

rec <- Recommender(train, method = "UBCF", param=list(method="Jaccard", normalize = NULL))
df_user_genres_top_n <- create_df_user_genres_top_n(rec, genres)
df_user_genres <- create_df_user_genres(df_user_genres_top_n, df_user_genres_best)
show_cleveland_dot_plot(df_user_genres, 'UBCF Recommender mit Jaccard Similarity')

rec <- Recommender(train, method = "POPULAR")
df_user_genres_top_n <- create_df_user_genres_top_n(rec, genres)
df_user_genres <- create_df_user_genres(df_user_genres_top_n, df_user_genres_best)
show_cleveland_dot_plot(df_user_genres, 'Popular Recommender')

rec <- Recommender(train, method = "SVD")
df_user_genres_top_n <- create_df_user_genres_top_n(rec, genres)
df_user_genres <- create_df_user_genres(df_user_genres_top_n, df_user_genres_best)
show_cleveland_dot_plot(df_user_genres, 'SVD Recommender')

Definiere eine Qualitätsmetrik für Top-N Listen und teste sie

algorithms <- list(
  "IBCF cosine" = list(name="IBCF", param=list(k = 30, method = "cosine", normalize = NULL, na_as_zero = TRUE), desc = 'IBCF Recommender mit Cosine Similarity'),
  "UBCF Jaccard" = list(name="UBCF", param=list(method = "jaccard"), desc = 'UBCF Recommender mit Jaccard Similarity'),
  "Popular" = list(name="POPULAR", param=NULL, desc = 'Popular Recommender'),
  "SVD" = list(name="SVD", param=NULL, desc = 'SVD Recommender')
)

errors <- vector()
algos <- vector()
for (algo in algorithms) {
  rec <- Recommender(train, method = algo$name, param=algo$param)
  df_user_genres_top_n <- create_df_user_genres_top_n(rec, genres)
  df_user_genres <- create_df_user_genres(df_user_genres_top_n, df_user_genres_best)
  error <- compute_mean_absolute_percentage_error(df_user_genres)
  algos <- c(algos, algo$desc)
  errors <- c(errors, error)
}

df_error <- data.frame(description = algos, error = errors)


ggplot(df_error, aes(x=description, y = error)) + 
  geom_col(fill = 'steelblue') +
  coord_flip() +
  scale_y_continuous(expand = c(0,0)) +
  geom_text(aes(label=error), hjust=1.5, color = 'white') +
  labs(
    title = "Mittlerer absoluter prozentualer Fehler der \nGenre-Anteile in den Top-N Empfehlungen",
    x = element_blank(), 
    y = "Mittlerer absoluter prozentualer Fehler",
    fill = element_blank()
  ) +
  theme_classic() + 
  theme(
    text = element_text(size = 12),
    legend.position = 'bottom'
  )

abs(df1_drama - df2_drama) + abs(df1_actions - df2_action) + …